home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / JARexx / ARexxCalls.f next >
Encoding:
FORTH Source  |  1990-07-27  |  6.6 KB  |  292 lines
  1. \ JForth V2.x interface for ARexx Library.  Mike Haas.  All Rights Reserved.
  2. \
  3. \ This file defines all the ARexx library functions, accepting
  4. \ and returning all arguments on the data stack (as you would
  5. \ expect).  Just watch the order of the returned values.
  6. \
  7. \ Addresses returned by ARexx will be converted to relative
  8. \ before being pushed on the stack.  ALL ADDRESSES (pointers),
  9. \ IN AND OUT OF THESE 'GLUE' ROUTINES, ARE IN JFORTH-RELATIVE FORM!
  10. \
  11. \ Some ARexx functions do wierd things like return multiple
  12. \ arguments in registers other than D0 and D1, so just the
  13. \ normal CALL & DCALL primitives don't suffice.
  14. \
  15. \ This source is highly JForth dependant, and not likely to
  16. \ be useful to a user of any other brand of Forth.
  17.  
  18.  
  19. anew Task-ARexxCalls.f
  20.  
  21.  
  22. \ IS THE AREXX LIBRARY DEFINED?...
  23.  
  24. .NEED RexxSysLib_lib
  25.  
  26.   :Library RexxSysLib
  27.   
  28.   : RexxSysLib?  RexxSysLib_name  RexxSysLib_lib  lib?   ;
  29.   
  30.   : -RexxSysLib  RexxSysLib_lib -lib  ;
  31.   
  32. .THEN
  33.  
  34.  
  35. \ SUPPORT FOR PUSHING THOSE MULTIPLE REGISTERS...
  36.  
  37. : TuckA0  ( -- , gen code to >REL on adr in A0, then push below TOS )
  38.   $ 91cc w,   \ suba.l  org,a0
  39.   $ 2d08 w,   \ move.l  a0,-(dsp)
  40. ;
  41. immediate
  42.  
  43. : TuckA1  ( -- , gen code to >REL on adr in A1, then push below TOS )
  44.   $ 93cc w,   \ suba.l  org,a1
  45.   $ 2d09 w,   \ move.l  a1,-(dsp)
  46. ;
  47. immediate
  48.  
  49. : TuckD1  ( -- , compile code to push value in d1 under TOS )
  50.   $ 2d01 w,   \ move.l  d1,-(dsp)
  51. ;
  52. immediate
  53.  
  54.  
  55. \ THE ACTUAL AREXX CALLS...
  56.  
  57. : ErrorMsg()  ( code -- StringStructure flag , 0=invalid code ) 
  58.   call RexxSysLib_lib ErrorMsg  TuckA0
  59. ;
  60.  
  61. : IsSymbol()  ( string -- length code , code=0 if not a symbol )
  62.   >abs dcall RexxSysLib_lib IsSymbol swap
  63. ;
  64.  
  65. : CurrentEnv()  ( RexxTaskPtr -- EnvPtr )
  66.   call>abs RexxSysLib_lib CurrentEnv if>rel
  67. ;
  68.  
  69. : GetSpace()  ( EnvPtr len -- ARexxMemBlk )
  70.   call>abs RexxSysLib_lib GetSpace if>rel
  71. ;
  72.  
  73. : FreeSpace()  ( EnvPtr ARexxMemBlk length -- )
  74.   call>abs RexxSysLib_lib FreeSpace drop
  75. ;
  76.  
  77. : CreateArgstring()  ( string len -- argstring )
  78.   call>abs RexxSysLib_lib CreateArgstring if>rel
  79. ;
  80.  
  81. : DeleteArgstring()  ( argstring -- )
  82.   >abs callvoid RexxSysLib_lib DeleteArgstring
  83. ;
  84.  
  85. : LengthArgstring()  ( argstring -- length )
  86.   call>abs RexxSysLib_lib LengthArgstring
  87. ;
  88.  
  89. : CreateRexxMsg()  ( replyport extensionPtr hostPtr -- msgPtr )
  90.   >abs call>abs RexxSysLib_lib CreateRexxMsg if>rel
  91. ;
  92.  
  93. : DeleteRexxMsg()  ( msgPtr -- )
  94.   call>abs RexxSysLib_lib DeleteRexxMsg drop
  95. ;
  96.  
  97. : ClearRexxMsg()  ( msgPtr numStrings -- )
  98.   call>abs RexxSysLib_lib ClearRexxMsg drop
  99. ;
  100.  
  101. : FillRexxMsg()  ( msgPtr count mask -- flag , 0=notsuccessful )
  102.   call>abs RexxSysLib_lib FillRexxMsg
  103. ;
  104.  
  105. : IsRexxMsg()  ( msgPtr -- flag )
  106.   call>abs RexxSysLib_lib IsRexxMsg
  107. ;
  108.  
  109. : AddRsrcNode()  ( list name len -- node-or-0 )
  110.   call>abs RexxSysLib_lib AddRsrcNode  if>rel
  111. ;
  112.  
  113. : FindRsrcNode()  ( list name len -- node-or-0 )
  114.   call>abs RexxSysLib_lib FindRsrcNode  if>rel
  115. ;
  116.  
  117. : RemRsrcList()  ( list -- )
  118.   >abs callvoid RexxSysLib_lib RemRsrcList
  119. ;
  120.  
  121. : RemRsrcNode()  ( node -- )
  122.   >abs callvoid RexxSysLib_lib RemRsrcNode
  123. ;
  124.  
  125. : OpenPublicPort()  ( list name -- node )
  126.   call>abs RexxSysLib_lib OpenPublicPort  if>rel
  127. ;
  128.  
  129. : ClosePublicPort()  ( node -- )
  130.   >abs callvoid RexxSysLib_lib ClosePublicPort
  131. ;
  132.  
  133. : ListNames()  ( list separator -- argstring )
  134.   call>abs RexxSysLib_lib ListNames if>rel
  135. ;
  136.  
  137. : ClearMem()  ( adr len -- )
  138.   call>abs RexxSysLib_lib ClearMem  drop
  139. ;
  140.  
  141. : InitList()  ( list -- )
  142.   >abs callvoid RexxSysLib_lib InitList
  143. ;
  144.  
  145. : InitPort()  ( port name -- port signal )
  146.   call>abs RexxSysLib_lib InitPort  TuckA1
  147. ;
  148.  
  149. : FreePort()  ( port -- )
  150.   >abs callvoid RexxSysLib_lib FreePort
  151. ;
  152.  
  153. : CmpString()  ( StringStructure1 StringStructure2 -- flag )
  154.   call>abs RexxSysLib_lib CmpString
  155. ;
  156.  
  157. : StcToken()  ( string -- token scan length quote )
  158.   call>abs RexxSysLib_lib StcToken  TuckA1 TuckA0 TuckD1
  159. ;
  160.  
  161. : StrcmpN()  ( string1 string2 len -- result )
  162.   call>abs RexxSysLib_lib StrcmpN
  163. ;
  164.  
  165. : StrcmpU()  ( string1 string2 len -- result )
  166.   call>abs RexxSysLib_lib StrcmpU
  167. ;
  168.  
  169. : StrcpyA()  ( dest source len -- hash )
  170.   call>abs RexxSysLib_lib StrcpyA
  171. ;
  172.  
  173. : StrcpyN()  ( dest source len -- hash )
  174.   call>abs RexxSysLib_lib StrcpyN
  175. ;
  176.  
  177. : StrcpyU()  ( dest source len -- hash )
  178.   call>abs RexxSysLib_lib StrcpyU
  179. ;
  180.  
  181. : StrFlipN()  ( string len -- )
  182.   call>abs RexxSysLib_lib StrFlipN drop
  183. ;
  184.  
  185. : Strlen()  ( string -- len )
  186.   call>abs RexxSysLib_lib Strlen
  187. ;
  188.  
  189. : ToUpper()  ( char -- char' )
  190.   call RexxSysLib_lib ToUpper
  191. ;
  192.  
  193. : CVa2i()  ( buffer -- value numDigits )
  194.   call>abs RexxSysLib_lib CVa2i  TuckD1
  195. ;
  196.  
  197. : CVi2a()  ( buffer value maxNumDigits -- buffer' numDigits )
  198.   call>abs RexxSysLib_lib CVi2a  TuckA0
  199. ;
  200.  
  201. : CVi2arg()  ( value -- argstring-or-0 )
  202.   call RexxSysLib_lib CVi2arg if>rel
  203. ;
  204.  
  205. : CVi2az()  ( buffer value numDigits<w/leadzeros> -- buffer' numDigits )
  206.   call>abs RexxSysLib_lib CVi2az  TuckA0
  207. ;
  208.  
  209. : CVc2x()  ( outbuff string len mode -- error )
  210.   call>abs RexxSysLib_lib CVc2x
  211. ;
  212.  
  213. : CVx2c()  ( outbuff string len mode -- error )
  214.   call>abs RexxSysLib_lib CVx2c
  215. ;
  216.  
  217. : OpenF()  ( list filename mode logical -- IoBuff )
  218.   3 x>r  >abs   r> >abs  r> r> if>abs  call RexxSysLib_lib OpenF if>rel
  219. ;
  220.  
  221. : CloseF()  ( IoBuff -- flag )
  222.   call>abs RexxSysLib_lib CloseF
  223. ;
  224.  
  225. : ReadStr()  ( IoBuff buffer len -- adr count , count=-1 if err )
  226.   call>abs RexxSysLib_lib ReadStr  TuckA1
  227. ;
  228.  
  229. : ReadF()  ( IoBuff buffer len -- count , count=-1 if err )
  230.   call>abs RexxSysLib_lib ReadF
  231. ;
  232.  
  233. : WriteF()  ( IoBuff buffer len -- count , count=-1 if err )
  234.   call>abs RexxSysLib_lib WriteF
  235. ;
  236.  
  237. : SeekF()  ( IoBuff offset anchor -- position )
  238.   call>abs RexxSysLib_lib SeekF
  239. ;
  240.  
  241. : QueueF()  ( IoBuff buffer len -- count , count=-1 if err )
  242.   call>abs RexxSysLib_lib QueueF
  243. ;
  244.  
  245. : StackF()  ( IoBuff buffer len -- count , count=-1 if err )
  246.   call>abs RexxSysLib_lib StackF
  247. ;
  248.  
  249. : ExistF()  ( filename -- flag )
  250.   call>abs RexxSysLib_lib ExistF
  251. ;
  252.  
  253. : DOSCommand()  ( string filehandle -- code )
  254.   call>abs RexxSysLib_lib DOSCommand
  255. ;
  256.  
  257. : DOSRead()  ( filehandle buffer len -- count , count=-1 if err )
  258.   call>abs RexxSysLib_lib DOSRead
  259. ;
  260.  
  261. : DOSWrite()  ( filehandle buffer len -- count , count=-1 if err )
  262.   call>abs RexxSysLib_lib DOSWrite
  263. ;
  264.  
  265. : CreateDOSPkt()  ( -- message )
  266.   call RexxSysLib_lib CreateDOSPkt  if>rel
  267. ;
  268.  
  269. : DeleteDOSPkt()  ( message -- )
  270.   >abs callvoid RexxSysLib_lib DeleteDOSPkt
  271. ;
  272.  
  273. : FindDevice()  ( devicename type -- device/0 )
  274.   call>abs RexxSysLib_lib FindDevice  if>rel
  275. ;
  276.  
  277. : AddClipNode()  ( list name len value -- node/0 )
  278.   3 x>r  >abs  r> >abs  r> r> >abs call RexxSysLib_lib AddClipNode if>rel
  279. ;
  280.  
  281. : RemClipNode()  ( mode -- )
  282.   >abs callvoid RexxSysLib_lib RemClipNode
  283. ;
  284.  
  285. : LockRexxBase()  ( resource -- )
  286.   callvoid RexxSysLib_lib LockRexxBase
  287. ;
  288.  
  289. : UnlockRexxBase()  ( resource -- )
  290.   callvoid RexxSysLib_lib UnlockRexxBase
  291. ;
  292.